#!/usr/bin/env perl

=head1 NAME

Merger

=head1 SYNOPSIS

use Merger;



=head1 DESCRIPTION

The merger combines a given set of subcomplexes with n domains to subcomplexes with n+1 domains. 

=head1 REQUIRES

sbglib, PDL

=head1 AUTHOR

Philipp Harth <phil.harth@gmail.com>

=cut

use PDL;
use Set::Scalar;
use Scorer;


package SubcomplexMerger;
use Moose;

#This module implements a levelwise merging scheme and is a main performance bottleneck. 
#To try a different merging scheme, implement an alternative method to 'mergePrefixMethod' below
#or replace the entire module.
#The 'mergePrefixMethod' is called in the QueryProcessor module in method 'query'. Also change the code
#there, if an alternative merging method is implemented.

has 'scorer' => (is => 'rw', isa=> 'Scorer');

#state variables for loops, should merging be interrupted
has 'i' => (is=>'rw', default=>0);
has 'j' => (is=>'rw', default=>0);
#is set to 1, if merging was interrupted
has 'frozen' => (is=>'rw', default=>0);
#currently only the loop counters are stored. It is assumed that the input and intermediate
#results are also conserved. This happens at the next higher level in 'QueryProcessor'.
#However, it would be more straightforward to store the input and the intermediate results
#in this module.

=head2 mergeSimilaritiesPrefixMethod

 Function: merges similarities to larger similarities  
 Example : 
 Returns : list of merged similarities with degree+1
 Args    : list of input similarities, mergeOps
 
The degree of the input similarities (i.e., the number of domains) must be the same.
The degree of the output similarities is increased by one. Only similarities that "survive"
the scoring process will be part of the output. 'mergeOps' specifies the maximal number of merge 
operations. If 'mergeOps' is reached, the merging stops, returns the intermediate results and the
state is conserved till the next call of 'mergePrefixMethod'.

=cut
sub mergePrefixMethod{
	
	#This merging scheme requires as intial input all domain pairs that don't violate distance 
	#constraints (as determined in a complete distance graph representation of the protein). 
	#If some initial subcomplexes are missing (as could be, if the initial domain pairs are determined
	#in a contact graph), the merging may not progress to the largest common subcomplex and be incomplete.

	my ($self, $subcomplexes, $mergeOps)= @_;
	
	my @mergedSubcomplexes = ();
	
	#determine number of domains in a subcomplex
	my $nDomains = 0;
	if(scalar(@{$subcomplexes}) != 0){
		$nDomains = scalar(@{@{$subcomplexes}[0]->domainsA});
	}
	
	#used to stop merging process if maximal number of operations has been reached
	my $innerLoopExecutions = 0;
	my $exitLoops = 0;
	
	#outer loop: init loop variable i with 'memory variable' $self->i
	for(my $i=$self->i; $i<scalar(@{$subcomplexes}); $i++){
		
		#inner loop: init loop variable j with 'memory variable' $self->j
		#if merging was not interruped, j starts at i (as would be if no interruption was implemented)
		my $j = 0;
		if(!$self->frozen){
			$j=$i;
		} else {
			$j=$self->j;
		}
		while($j<scalar(@{$subcomplexes})){

			my $s1 = @{$subcomplexes}[$i];
			my $s2 = @{$subcomplexes}[$j];
			if($s1 != $s2){
				# s1 and s2 must have different postfix
				my $eligible = ((@{$s1->domainsA}[$nDomains-1] ne @{$s2->domainsA}[$nDomains-1]) &&
								(@{$s1->domainsB}[$nDomains-1] ne @{$s2->domainsB}[$nDomains-1]));
				# s1 and s2 must have same prefix
				for(my $i=0; $i<$nDomains-1; $i++){
					if((@{$s1->domainsA}[$i] ne @{$s2->domainsA}[$i]) ||
					   (@{$s1->domainsB}[$i] ne @{$s2->domainsB}[$i])){
						$eligible = 0;
					}
				}
				#try to merge s1 and s2 if they have same prefix and different postfix
				if($eligible){
					my $sMerged = $self->merge($s1,$s2,$nDomains);
					#measure new subcomplex to determine if it qualifies for the next stage
					$self->scorer->measureSubcomplex($sMerged);
					if($sMerged->score){ #score will be 0 if it does not qualify
						push @mergedSubcomplexes, $sMerged;
					}					
				}
			}
			
			$j++;
			$innerLoopExecutions++;
			
			#check if maximal number of merge operations has been reached 
			if($innerLoopExecutions >= $mergeOps){
				$exitLoops = 1;
				$self->frozen(1);
				#save loop counters
				if($j >= scalar(@{$subcomplexes})){
					$self->i($i+1);
					$self->j($i+1);
				} else {
					$self->i($i);
					$self->j($j);
				}
				
			}
				
			last if $exitLoops;
		}
		if(!$exitLoops){
			$self->frozen(0);
		}
		
		last if $exitLoops;
	}

	#check if merging is completely finished or needs another round
	if($exitLoops){
		#merging was interrupted
		return (0, @mergedSubcomplexes);
	} else {	
		#merging was finished
		$self->i(0);
		$self->j(0);
		return (1, @mergedSubcomplexes);
	}
}

=head2 reset

 Function: resets state variables
 Example : 
 Returns : 
 Args    :
 
Sets the state variables back to default, any conserved state is lost.

=cut
sub reset {
	my ($self) = @_;
	$self->i(0);
	$self->j(0);
	$self->frozen(0);
}

=head2 merge

 Function: merges two subcomplexes into new subcomplex
 Example : 
 Returns : subcomplex
 Args    : subcomplex1, subcomplex2, nDomains
 
Merges two subcomplexes with 'nDomains' domains into a subcomplex of 
'nDomains'+1 domains. The function expects 'subcomplex1' and 'subcomplex2' to 
be the same in prefix, but to differ in postfix. 

=cut	
sub merge{
	my ($self, $s1, $s2, $nDomains) = @_;
		
	my @domainsS1A = @{$s1->domainsA};
	my @domainsS2A = @{$s2->domainsA};
	my @domainsS1B = @{$s1->domainsB};
	my @domainsS2B = @{$s2->domainsB};
	
	#set attributes of new subcomplex
	my $sMerged = Subcomplex->new(numberOfDomains=>$nDomains+1);
	$sMerged->complexA($domainsS1A[0]->pdbid);
	$sMerged->complexB($domainsS1B[0]->pdbid);
	
	#set domains of new subcomplex maintaining an alphabetic order on the 
	#based on the ids of the domains
	if($domainsS1A[$nDomains-1]->id lt $domainsS2A[$nDomains-1]->id){
		push @{$sMerged->domainsA}, @domainsS1A, $domainsS2A[$nDomains-1];
		push @{$sMerged->domainsB}, @domainsS1B, $domainsS2B[$nDomains-1];
	} else {
		push @{$sMerged->domainsA}, @domainsS2A, $domainsS1A[$nDomains-1];
		push @{$sMerged->domainsB}, @domainsS2B, $domainsS1B[$nDomains-1];
	}
	
	return $sMerged;
}

no Moose;
1;

